--{-# LANGUAGE CPP, RankNTypes, FunctionalDependencies,FlexibleContexts, GeneralizedNewtypeDeriving, TypeOperators, GADTs, MultiParamTypeClasses, UndecidableInstances, FlexibleInstances, DeriveDataTypeable, ScopedTypeVariables, ExistentialQuantification, TypeFamilies #-}
{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving, TypeFamilies, FlexibleContexts #-}
{- |
Module      :  Model
Description :  <optional short text displayed on contents page>
Copyright   :  (c) Sergey Sichevskiy 2012
License     :  BSD3

Maintainer  :  s.sichevskij@gmal.com
Stability   :  experimental
Portability :  portable


-}

module Model where

import Helper
import Data.HList

import Text.Printf (printf)

--type Model a b = HList a => a -> b

newtype Ebv   = Ebv   Double deriving (Show, Read, Num, Eq, Ord)
newtype Theta = Theta Double deriving (Show, Read, Num, Eq, Ord)
newtype Teff  = Teff  Double deriving (Show, Read, Num, Eq, Ord) 
newtype Logg  = Logg  Double deriving (Show, Read, Num, Eq, Ord)
newtype FeH   = FeH   Double deriving (Show, Read, Num, Eq, Ord)
newtype Vtur  = Vtur  Double deriving (Show, Read, Num, Eq, Ord)
newtype Sp    = Sp    Double deriving (Show, Read, Num, Eq, Ord)
newtype Dist  = Dist  Double deriving (Show, Read, Num, Eq, Ord)

instance HApplay ToDouble Ebv   where applay _ (Ebv   v) = v
instance HApplay ToDouble Theta where applay _ (Theta v) = v
instance HApplay ToDouble Teff  where applay _ (Teff  v) = v
instance HApplay ToDouble Logg  where applay _ (Logg  v) = v
instance HApplay ToDouble FeH   where applay _ (FeH   v) = v
instance HApplay ToDouble Vtur  where applay _ (Vtur  v) = v
instance HApplay ToDouble Sp    where applay _ (Sp    v) = v
instance HApplay ToDouble Dist  where applay _ (Dist  v) = v

--{--
instance HApplay FromDouble (Sp,Double)   where applay _ (_,v) = Sp   v
instance HApplay FromDouble (Ebv,Double)  where applay _ (_,v) = Ebv  v
instance HApplay FromDouble (Teff,Double) where applay _ (_,v) = Teff v
instance HApplay FromDouble (Logg,Double) where applay _ (_,v) = Logg v
--}

lift :: (HSplitAt2 xs ys) => (a -> b -> c) -> (xs -> a) -> (ys -> b) -> Append xs ys -> c
lift f fa fb = (\(x,y) -> f (fa x) (fb y)) . hSplitAt2 n
  where
   n = undefined -- :: Length xs

{--
lift :: ( n ~ Length xs , HSplitAt n xy , (xs, ys) ~ SplitAt n xy ) => (a -> b -> c) -> (xs -> a) -> (ys -> b) -> xy -> c
lift f fa fb = split f fa fb undefined
  where
   split :: ( n ~ Length xs , HSplitAt n xy , (xs, ys) ~ SplitAt n xy ) => (a -> b->c) -> (xs -> a) -> (ys -> b) -> Length xs -> xy -> c
   split f fa fb n  = (\(x,y) -> f (fa x) (fb y)) . hSplitAt n
--}


(.$) :: (HSplitAt2 xs ys) => (xs -> (a->b)) -> (ys -> a) -> (Append xs ys) -> b
(.$) = lift ($)

(.+) :: (Num a, HSplitAt2 xs ys) => (xs -> a) -> (ys -> a) -> (Append xs ys) -> a
(.+) = lift (+)

(.-) :: (Num a, HSplitAt2 xs ys) => (xs -> a) -> (ys -> a) -> (Append xs ys) -> a
(.-) = lift (-)

(.*) :: (Num a, HSplitAt2 xs ys) => (xs -> a) -> (ys -> a) -> (Append xs ys) -> a
(.*) = lift (*)

(.++.) :: (HSplitAt2 xs ys, HAppend as bs) => (xs -> as) -> (ys -> bs) -> (Append xs ys) -> (Append as bs)
(.++.) = lift (hAppend)

(.+.) :: (Num a, HAppend xs ys, HSplitAt2 xs ys, HSplitAt2 bs cs) => (bs -> xs, xs -> a) -> (cs -> ys, ys -> a) -> ( (Append bs cs -> Append xs ys), (Append xs ys -> a) )
(.+.) (fb,fa) (gb,ga) = (fb .++. gb, fa .+ ga)

(.-.) :: (Num a, HAppend xs ys, HSplitAt2 xs ys, HSplitAt2 bs cs) => (bs -> xs, xs -> a) -> (cs -> ys, ys -> a) -> ( (Append bs cs -> Append xs ys), (Append xs ys -> a) )
(.-.) (fb,fa) (gb,ga) = (fb .++. gb, fa .- ga)

(.*.) :: (Num a, HAppend xs ys, HSplitAt2 xs ys, HSplitAt2 bs cs) => (bs -> xs, xs -> a) -> (cs -> ys, ys -> a) -> ( (Append bs cs -> Append xs ys), (Append xs ys -> a) )
(.*.) (fb,fa) (gb,ga) = (fb .++. gb, fa .* ga)


--{--
($$) :: ( xs'~ Map ToDouble xs
        , zs ~ Zip xs xs'
        , xs ~ Map FromDouble zs
        , HZip xs xs'
        , HFromList Double xs'
        , HMap FromDouble zs

        , HMap ToDouble ys
        , HToList (Map ToDouble ys) Double
        ) => (xs -> ys) -> xs -> [Double] -> [Double]
($$) f xs vs = hToList $ hMap ToDouble $ (f $ xs `updateBy` vs)
--($$) f xs vs = hToList $ hMap ToDouble $ f $ hMap ToDouble (xs `updateBy` vs)


updateBy :: ( HZip xs ys
        , HFromList Double ys
        , HMap FromDouble  zs
        , ys ~ Map ToDouble xs
        , zs ~ Zip xs ys
        , xs ~ Map FromDouble zs
        )
      => xs -> [Double] -> xs
updateBy xs =  updateBy' xs . hFromList
  where
   updateBy' :: ( HZip xs ys
            , HMap FromDouble zs
            , ys ~ Map ToDouble xs
            , zs ~ Zip xs ys
            , xs ~ Map FromDouble zs
            )
          => xs -> ys -> xs
   updateBy' xs ys = hMap FromDouble $ hZip xs ys


#define PRETTYSHOW(T)                              \
instance PrettyShow (T)                            \
   where                                           \
      prettyShow (T v) = printf "%5s = %10.4f" "T" v 

PRETTYSHOW(Ebv)
PRETTYSHOW(Theta)
PRETTYSHOW(Teff)
PRETTYSHOW(Logg)
PRETTYSHOW(FeH)
PRETTYSHOW(Vtur)
PRETTYSHOW(Sp)
PRETTYSHOW(Dist)